home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / tool_inc.zip / PATTERN.INC < prev    next >
Text File  |  1989-06-02  |  4KB  |  159 lines
  1.  
  2. (*
  3.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13. (*
  14.  * pattern match function - matches a unix-style filename pattern.
  15.  *      this recursive definition will accept *key* forms.
  16.  *
  17.  * S.H.Smith, rev. 04-Oct-87 (rev. 12-01-88)
  18.  *
  19.  *)
  20.  
  21. {$DEFINE PATTERN_MATCH}
  22.  
  23. (* these static variables are part of a hack to speed up the recursive
  24.    pattern matching operation.  *)
  25.  
  26. var
  27.    PAT_pattern:        string13;
  28.    PAT_pc:             integer;
  29.    PAT_line:           string13;
  30.    PAT_lc:             integer;
  31.  
  32.  
  33. (* matching engine - uses pointers into static pattern and line strings *)
  34.  
  35. function PAT_match (patpos,
  36.                     linpos:             integer): boolean;
  37. const
  38.    QUESTION =          63;    {ord('?')}
  39.    STAR =              42;    {ord('*')}
  40.    ENDSTR =            32;    {ord(' ')}
  41.    
  42. label 
  43.    continue;
  44.  
  45. begin
  46.    PAT_match := false;
  47.  
  48. (* do a "wildcard" filename scan *)
  49.    
  50.    repeat
  51. continue :
  52.       PAT_pc := ord (PAT_pattern [patpos]);  {get next pattern character}
  53.       PAT_lc := ord (PAT_line [linpos]);     {get next line character}
  54.  
  55. (* end of pattern?  we might have a match if so *)
  56.       
  57.       if patpos > length(PAT_pattern) then
  58.       begin
  59.          PAT_match := PAT_lc = ENDSTR;
  60.          exit;
  61.       end
  62.       else
  63.  
  64. (* does line match pattern?  step forward if so *)
  65.       
  66.       if (PAT_pc = PAT_lc) then
  67.       begin
  68.          inc(patpos);
  69.          inc(linpos);
  70.          goto continue;
  71.       end
  72.       else
  73.  
  74. (* end of line?  we missed a match if so *)
  75.       
  76.       if PAT_lc = ENDSTR then
  77.          exit
  78.       else
  79.  
  80. (* ? matches anything *)
  81.       
  82.       if (PAT_pc = QUESTION) then
  83.       begin
  84.          inc(patpos);
  85.          inc(linpos);
  86.          goto continue;
  87.       end
  88.       else
  89.  
  90. (* '*' matches 0 or more characters, anywhere in string *)
  91.       
  92.       if PAT_pc = STAR then
  93.       begin
  94.          
  95.          if patpos = length(PAT_pattern) then
  96.          begin
  97.             PAT_match := true;
  98.             exit;
  99.          end;
  100.          
  101.          inc(patpos);
  102.          
  103.          repeat
  104.             
  105.             if PAT_match (patpos, linpos) then
  106.             begin
  107.                PAT_match := true;
  108.                exit;
  109.             end;
  110.             
  111.             inc(linpos);
  112.             PAT_lc := ord (PAT_line [linpos]);
  113.          until PAT_lc = ENDSTR;
  114.          
  115.          exit;
  116.       end
  117.       else
  118. (* else no match is possible; terminate scan *)
  119.          exit;
  120.  
  121.    until false;
  122. end;
  123.  
  124. function wildcard_match (var pattern,
  125.                          line:               string65): boolean;
  126.                            {pattern must be upper case; line is not case 
  127.                              sensitive}
  128. begin
  129.  
  130. (* test for special case that matches all filenames *)
  131.    
  132.    if pattern[1] = '*' then
  133.    begin
  134.       if (pattern = '*.*') or
  135.         ((pattern = '*.') and (pos('.',copy(line,1,9)) = 0)) then
  136.       begin
  137.          wildcard_match := true;
  138.          exit;
  139.       end;
  140.    end;
  141.  
  142.    PAT_pattern := pattern;
  143.    PAT_line := line;
  144.  
  145. (* force a space as end-of-string character to simplify *)
  146.    
  147.    if length(PAT_line) > 12 then
  148.       PAT_line[0]:= chr (12);
  149.    
  150.    if PAT_line[length(PAT_line)] <> ' ' then
  151.       PAT_line := PAT_line + ' ';
  152.  
  153. (* perform the match test *)
  154.    
  155.    stoupper(PAT_line);
  156.    wildcard_match := PAT_match (1, 1);
  157. end;
  158.  
  159.